home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / hyperbole / hbut.el < prev    next >
Encoding:
Text File  |  1995-04-17  |  41.9 KB  |  1,188 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         hbut.el
  4. ;; SUMMARY:      Hyperbole button constructs.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     extensions, hypermedia
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Brown U.
  10. ;;
  11. ;; ORIG-DATE:    18-Sep-91 at 02:57:09
  12. ;; LAST-MOD:     14-Apr-95 at 16:01:20 by Bob Weiner
  13. ;;
  14. ;; This file is part of Hyperbole.
  15. ;; Available for use and distribution under the same terms as GNU Emacs.
  16. ;;
  17. ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
  18. ;; Developed with support from Motorola Inc.
  19. ;;
  20. ;; DESCRIPTION:  
  21. ;; DESCRIP-END.
  22.  
  23. ;;; ************************************************************************
  24. ;;; Other required Elisp libraries
  25. ;;; ************************************************************************
  26.  
  27. (require 'hmoccur)
  28. (require 'hbmap)
  29. (require 'htz)
  30. (require 'hbdata)
  31. (require 'hact)
  32.  
  33. ;;; ************************************************************************
  34. ;;; Public definitions
  35. ;;; ************************************************************************
  36.  
  37. ;;; ========================================================================
  38. ;;; ebut class - Explicit Hyperbole buttons
  39. ;;; ========================================================================
  40.  
  41. (defvar   ebut:hattr-save t
  42.   "*Non-nil value saves button data when button source is saved.
  43. Nil disables saving.")
  44.  
  45. (defconst ebut:max-len 100
  46.   "Maximum length of a hyper-button label.")
  47.  
  48.  
  49. (defun    ebut:alist (&optional file)
  50.   "Returns alist with each element a list containing a button label.
  51. For use as a completion table.  Gets labels from optional FILE or current
  52. buffer."
  53.   (mapcar 'list (ebut:list file)))
  54.  
  55. (defun    ebut:at-p (&optional start-delim end-delim)
  56.   "Returns explicit Hyperbole button at point or nil.
  57. Assumes point is within first line of button label, if at all.
  58. Optional START-DELIM and END-DELIM are strings that override default
  59. button delimiters."
  60.   (let ((key (ebut:label-p nil start-delim end-delim)))
  61.     (and key (ebut:get key))))
  62.  
  63. (defun    ebut:create (&optional but-sym)
  64.   "Creates Hyperbole explicit button based on optional BUT-SYM.
  65. Default is 'hbut:current'.
  66. Button should hold the following attributes (see 'hattr:set'): 
  67.    lbl-key (normalized button label string),
  68.    loc     (filename or buffer where button is located),
  69.    dir     (directory name where button is located),
  70.    actype  (action type that provides a default action for the button),
  71.    action  (optional action that overrides the default),
  72.    args    (list of arguments for action, if action takes a single
  73.             argument of the button lbl-key, args may be nil).
  74.  
  75. If successful returns any instance number to append to button label
  76. except when instance number would be 1, then returns t.  On failure,
  77. returns nil.
  78.  
  79. If successful, leaves point in button data buffer, so caller should use
  80. 'save-excursion'.  Does not save button data buffer."
  81.   (let ((lbl-instance (hbdata:write nil but-sym)))
  82.     (run-hooks 'ebut:create-hook)
  83.     lbl-instance))
  84.  
  85. (defun    ebut:delete (&optional but-sym)
  86.   "Deletes Hyperbole explicit button based on optional BUT-SYM.
  87. Default is 'hbut:current'.
  88. Returns entry deleted (a list of attribute values) or nil."
  89.   (if (null but-sym) (setq but-sym 'hbut:current))
  90.   (if (ebut:is-p but-sym)
  91.       (let* ((but-key (hattr:get but-sym 'lbl-key)) 
  92.          (loc     (hattr:get but-sym 'loc))
  93.          (entry   (hbdata:delete-entry but-key loc)))
  94.     (run-hooks 'ebut:delete-hook)
  95.     entry)))
  96.  
  97. (defun    ebut:get (&optional lbl-key buffer key-src)
  98.   "Returns explicit Hyperbole button symbol given by LBL-KEY and BUFFER.
  99. KEY-SRC is given when retrieving global buttons and is full source pathname.
  100. Retrieves button data, converts into a button object and returns a symbol
  101. which references the button.
  102.  
  103. All arguments are optional.  When none are given, returns symbol for
  104. button that point is within or nil.  BUFFER defaults to the current
  105. buffer."
  106.   (hattr:clear 'hbut:current)
  107.   (save-excursion
  108.     (let ((key-file) (key-dir) (but-data) (actype))
  109.       (or lbl-key (setq lbl-key (ebut:label-p)))
  110.       (if buffer
  111.       (if (bufferp buffer) (set-buffer buffer)
  112.         (error "(ebut:get): Invalid buffer argument: %s" buffer)))
  113.       (if key-src
  114.       nil
  115.     (if (equal lbl-key (ebut:label-p))
  116.         nil
  117.       (goto-char (point-min))
  118.       (ebut:next-occurrence lbl-key))
  119.     (if (setq key-src (ebut:key-src 'full))
  120.         ;; 'ebut:key-src' sets current buffer to key-src buffer.
  121.         (setq buffer (current-buffer)))
  122.     )
  123.       (if (and (stringp lbl-key) key-src)
  124.       (progn
  125.         (if (stringp key-src)
  126.         (setq key-dir (file-name-directory key-src)
  127.               key-file (file-name-nondirectory key-src)))
  128.         (setq but-data (and key-src
  129.                 (hbdata:get-entry lbl-key (or key-file key-src)
  130.                           key-dir)))
  131.         (if (null but-data)
  132.         nil
  133.           (hattr:set 'hbut:current 'lbl-key lbl-key)
  134.           (hattr:set 'hbut:current 'loc key-src)
  135.           (hattr:set 'hbut:current 'categ 'explicit)
  136.           (hattr:set 'hbut:current 'action nil)
  137.           (hattr:set 'hbut:current 'actype
  138.              (intern (setq actype (hbdata:actype but-data))))
  139.           ;; Hyperbole V1 referent compatibility
  140.           (if (= (length actype) 2)
  141.           (hattr:set 'hbut:current 'referent
  142.                  (hbdata:referent but-data)))
  143.           (hattr:set 'hbut:current 'args (hbdata:args but-data))
  144.           (hattr:set 'hbut:current 'creator (hbdata:creator but-data))
  145.           (hattr:set 'hbut:current
  146.              'create-time (hbdata:create-time but-data))
  147.           (hattr:set 'hbut:current
  148.              'modifier (hbdata:modifier but-data))
  149.           (hattr:set 'hbut:current
  150.              'mod-time (hbdata:mod-time but-data))
  151.           'hbut:current)
  152.         )))))
  153.  
  154. (defun    ebut:is-p (object)
  155.   "Returns non-nil if OBJECT denotes an explicit Hyperbole button."
  156.   (and (symbolp object)
  157.        (eq (hattr:get object 'categ) 'explicit)))
  158.  
  159. (defun    ebut:key-of-label-p (key label)
  160.   "Returns t iff KEY matches to LABEL in a case insensitive manner."
  161.   (and (stringp key) (stringp label)
  162.        (equal key (downcase (ebut:label-to-key label)))))
  163.  
  164. (defun    ebut:key-src (&optional full)
  165.   "Return key source (usually unqualified) for current Hyperbole button.
  166. Also sets current buffer to key source.
  167. With optional FULL when source is a pathname, the full pathname is returned."
  168.   (let ((src (cond ((hmail:mode-is-p) (current-buffer))
  169.            ((ebut:key-src-fmt))
  170.            ((save-excursion
  171.               (save-restriction
  172.             (widen)
  173.             (if (and (search-backward hbut:source-prefix nil t)
  174.                  (or (= (preceding-char) ?\n) (= (point)
  175.                                  (point-min))))
  176.                 (hbut:source full)))))
  177.            (buffer-file-name
  178.             (if full buffer-file-name
  179.               (file-name-nondirectory buffer-file-name)))
  180.            (t (current-buffer))
  181.            )))
  182.     (cond ((null src) nil)
  183.       ((bufferp src)
  184.        (set-buffer src)
  185.        src)
  186.       ((file-readable-p src)
  187.        (set-buffer (find-file-noselect src))
  188.        src)
  189.       ((file-readable-p (setq src (hpath:symlink-referent src)))
  190.        (set-buffer (find-file-noselect src))
  191.        src))))
  192.  
  193. (defun    ebut:key-src-fmt ()
  194.   "Returns unformatted filename associated with formatted current buffer.
  195. This is used to obtain the source of explicit buttons for buffers that
  196. represent the output of particular document formatters."
  197.   (cond ((or (eq major-mode 'Info-mode)
  198.          (string-match "\\.info\\(-[0-9]+\\)?$" (buffer-name)))
  199.      (let ((src (and buffer-file-name
  200.              (substring
  201.               buffer-file-name
  202.               0 (string-match "\\.[^.]+$" buffer-file-name)))))
  203.        (cond ((file-exists-p (concat src ".texi"))
  204.           (concat src ".texi"))
  205.          ((file-exists-p (concat src ".texinfo"))
  206.           (concat src ".texinfo"))
  207.          ((current-buffer)))))
  208.     ))
  209.  
  210. (defun    ebut:key-to-label (lbl-key)
  211.   "Unnormalizes LBL-KEY and returns a label string approximating actual label."
  212.   (if lbl-key
  213.       (let* ((pos 0) (len (length lbl-key)) (lbl) c)
  214.     (while (< pos len)
  215.       (setq c (aref lbl-key pos)
  216.         lbl (concat lbl 
  217.                 (if (= c ?_)
  218.                 (if (or (= (1+ pos) len)
  219.                     (/= (aref lbl-key (1+ pos)) ?_))
  220.                     " "
  221.                   (setq pos (1+ pos))
  222.                   "_")
  223.                   (char-to-string c)))
  224.         pos (1+ pos)))
  225.     lbl)))
  226.  
  227. (defun    ebut:label-p (&optional as-label start-delim end-delim pos-flag)
  228.   "Returns key for Hyperbole button label that point is within.
  229. Returns nil if not within a label.
  230. Assumes point is within first line of button label, if at all.
  231. If optional AS-LABEL is non-nil, label is returned rather than the key
  232. derived from the label.  Optional START-DELIM and END-DELIM are strings
  233. that override default button delimiters.  With optional POS-FLAG non-nil,
  234. returns list of label-or-key, but-start-position, but-end-position.
  235. Positions include delimiters."
  236.   (let ((opoint (point))
  237.     (npoint (1+ (point)))
  238.     (quoted "\\(^\\|[^\\{]\\)")
  239.     (start)
  240.     lbl-key end but-start but-end)
  241.     (or start-delim (setq start-delim ebut:start))
  242.     (or end-delim (setq end-delim ebut:end))
  243.     (save-excursion
  244.       (beginning-of-line)
  245.       (while (and (progn
  246.             (while (re-search-forward
  247.                 (concat quoted (regexp-quote start-delim))
  248.                 npoint t)
  249.               (setq start t))
  250.             start)
  251.           (re-search-forward (concat "[^\\{]" (regexp-quote end-delim))
  252.                      npoint t))
  253.     (setq start nil))
  254.       (if start
  255.       (progn
  256.         (setq start (point)
  257.           but-start (match-end 1))
  258.         (if (= ?\( (char-syntax (preceding-char)))
  259.         (condition-case ()
  260.             (progn
  261.               (forward-char -1)
  262.               (forward-list)
  263.               (forward-char -2))
  264.           (error (goto-char (1- opoint))))
  265.           (goto-char (1- opoint)))
  266.         (and (< (point) (+ start ebut:max-len))
  267.          (re-search-forward (concat quoted (regexp-quote end-delim))
  268.                     (+ start ebut:max-len) t)
  269.          (setq but-end (point)
  270.                end (- (point) (length end-delim))
  271.                lbl-key (ebut:label-to-key (buffer-substring start end)))
  272.          (cond (pos-flag
  273.             (if as-label
  274.                 (list (ebut:key-to-label lbl-key) but-start but-end)
  275.               (list lbl-key but-start but-end)))
  276.                (t (if as-label (ebut:key-to-label lbl-key) lbl-key)))))))))
  277.  
  278. (defun    ebut:label-regexp (lbl-key &optional no-delim)
  279.   "Unnormalizes LBL-KEY.  Returns regular expr matching delimited but label.
  280. Optional NO-DELIM leaves off delimiters and leading and trailing space."
  281.   (if lbl-key
  282.       (let* ((pos 0)
  283.          (len (length lbl-key))
  284.          (c)
  285.          (sep0 "[ \t\n\^M]*")
  286.          (sep "[ \t\n\^M]+")
  287.          (regexp (if no-delim "" (concat (regexp-quote ebut:start) sep0)))
  288.          (case-fold-search))
  289.     (while (< pos len)
  290.       (setq c (aref lbl-key pos)
  291.         regexp (concat regexp 
  292.                    (if (= c ?_)
  293.                    (if (or (= (1+ pos) len)
  294.                        (/= (aref lbl-key (1+ pos)) ?_))
  295.                        sep
  296.                      (setq pos (1+ pos))
  297.                      "_")
  298.                  (regexp-quote (char-to-string c))))
  299.         pos (1+ pos)))
  300.     (if no-delim regexp 
  301.       (setq regexp (concat regexp sep0 (regexp-quote ebut:end)))))))
  302.  
  303. (defun    ebut:label-to-key (label)
  304.   "Normalizes LABEL for use as a Hyperbole button key and returns key.
  305. Eliminates any fill prefix in the middle of the label, replaces '_' with
  306. '__', removes leading and trailing whitespace and replaces each other
  307. whitespace sequence with '_'."
  308.   (if (null label)
  309.       nil
  310.     (setq label (hbut:fill-prefix-remove label)
  311.       ;; Remove leading and trailing space.
  312.       label (hypb:replace-match-string "\\`[ \t\n\^M]+\\|[ \t\n\^M]+\\'"
  313.                        label "")
  314.       label (hypb:replace-match-string "_" label "__" t))
  315.     (hypb:replace-match-string "[ \t\n\^M]+" label "_" t)))
  316.  
  317. (defun    ebut:list (&optional file loc-p)
  318.   "Returns list of button labels from given FILE or current buffer.
  319. Removes duplicate labels if optional LOC-P is omitted.  With LOC-P, returns
  320. list of elements (label start end) where start and end are the buffer
  321. positions at which the starting button delimiter begins and ends."
  322.   (interactive)
  323.   (setq file (if file (and (file-exists-p file) (find-file-noselect file))
  324.            (current-buffer)))
  325.   (if file
  326.       (progn
  327.     (set-buffer file)
  328.     (let ((buts (ebut:map (if loc-p
  329.                   (function
  330.                    (lambda (lbl start end)
  331.                      ;; Normalize label spacing
  332.                      (list (ebut:key-to-label
  333.                         (ebut:label-to-key lbl))
  334.                        start end)))
  335.                 (function
  336.                  (lambda (lbl start end)
  337.                    ;; Normalize label spacing
  338.                    (ebut:key-to-label
  339.                     (ebut:label-to-key lbl))))))))
  340.       (if loc-p buts (nreverse (set:create buts)))))))
  341.  
  342. (fset    'map-ebut 'ebut:map)
  343. (defun    ebut:map (but-func &optional start-delim end-delim
  344.                  regexp-match include-delims)
  345.   "Applies BUT-FUNC to buttons delimited by optional START-DELIM and END-DELIM.
  346. If REGEXP-MATCH is non-nil, only buttons which match this argument are
  347. considered.
  348. Maps over portion of buffer visible under any current restriction.
  349. BUT-FUNC must take precisely three arguments: the button label, the
  350. start position of the delimited button label and its end position (positions
  351. include delimiters when INCLUDE-DELIMS is non-nil).
  352. If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular
  353. expression which matches an entire button string."
  354.   (or start-delim (setq start-delim ebut:start))
  355.   (or end-delim (setq end-delim ebut:end))
  356.   (let* ((regexp (symbolp end-delim))
  357.      (end-sym (or regexp (substring end-delim -1)))
  358.      (rtn)
  359.      (quoted)
  360.      start end but lbl)
  361.     (save-excursion
  362.       (goto-char (point-min))
  363.       (setq include-delims (if include-delims 0 1))
  364.       (while (re-search-forward
  365.           (if regexp start-delim
  366.         (concat (regexp-quote start-delim)
  367.             "\\([^" end-sym "\"][^" end-sym "]*\\)"
  368.             (regexp-quote end-delim)))
  369.           nil t)
  370.     (setq start (match-beginning include-delims)
  371.           end (match-end include-delims)
  372.           but (buffer-substring (match-beginning 0) (match-end 0))
  373.           lbl (buffer-substring (match-beginning 1) (match-end 1)))
  374.     (save-excursion
  375.       (goto-char start)
  376.       (if (or (= (preceding-char) ?\\) (= (preceding-char) ?\{))
  377.           ;; Ignore matches with quoted delimiters.
  378.           (setq quoted t)))
  379.     (cond (quoted (setq quoted nil))
  380.           ((or (not regexp-match)
  381.            (string-match regexp-match but))
  382.            (setq rtn (cons (funcall but-func lbl start end) rtn))))))
  383.     (nreverse rtn)))
  384.  
  385. (defun    ebut:modify (&optional lbl-key but-sym)
  386.   "Modifies existing Hyperbole button from optional LBL-KEY and BUT-SYM.
  387. Defaults are the key for any button label at point and 'hbut:current'.
  388. If successful, returns button's instance number except when instance
  389. number is 1, then returns t.  On failure, as when button does not exist,
  390. returns nil.
  391.  
  392. If successful, leaves point in button data buffer, so caller should use
  393. 'save-excursion'.  Does not save button data buffer."
  394.   (save-excursion
  395.     (let ((lbl-instance (hbdata:write lbl-key but-sym)))
  396.       (run-hooks 'ebut:modify-hook)
  397.       lbl-instance)))
  398.  
  399. (defun    ebut:next-occurrence (lbl-key &optional buffer)
  400.   "Moves point to next occurrence of button with LBL-KEY in optional BUFFER.
  401. BUFFER defaults to current buffer.  It may be a buffer name.
  402. Returns non-nil iff occurrence is found.
  403.  
  404. Remember to use (goto-char (point-min)) before calling this in order to
  405. move to the first occurrence of the button."
  406.   (if buffer
  407.       (if (not (or (bufferp buffer)
  408.            (and (stringp buffer) (get-buffer buffer))))
  409.       (error "(ebut:next-occurrence): Invalid buffer arg: %s" buffer)
  410.     (switch-to-buffer buffer)))
  411.   (if (re-search-forward (ebut:label-regexp lbl-key) nil t)
  412.       (goto-char (+ (match-beginning 0) (length ebut:start)))))
  413.  
  414. (defun    ebut:operate (curr-label new-label)
  415.   "Operates on a new or existing Hyperbole button given by CURR-LABEL.
  416. When NEW-LABEL is non-nil, this is substituted for CURR-LABEL and the
  417. associated button is modified.  Otherwise, a new button is created.
  418. Returns instance string appended to label to form unique label, nil if
  419. label is already unique.  Signals an error when no such button is found
  420. in the current buffer."
  421.   (let* ((lbl-key (ebut:label-to-key curr-label))
  422.      (lbl-regexp (ebut:label-regexp lbl-key))
  423.      (modify new-label)
  424.      (instance-flag))
  425.     (or new-label (setq new-label curr-label))
  426.     (hattr:set 'hbut:current 'lbl-key (ebut:label-to-key new-label))
  427.     (save-excursion
  428.       (if (setq instance-flag
  429.         (if modify (ebut:modify lbl-key) (ebut:create)))
  430.       (if (hmail:editor-p) (hmail:msg-narrow))))
  431.     (if instance-flag
  432.     (progn
  433.       ;; Rename all occurrences of button - those with same label.
  434.       (if modify
  435.           (let* ((but-key-and-pos (ebut:label-p nil nil nil 'pos))
  436.              (at-but (equal (car but-key-and-pos)
  437.                     (ebut:label-to-key new-label))))
  438.         (if at-but
  439.             (ebut:delimit (nth 1 but-key-and-pos)
  440.                   (nth 2 but-key-and-pos)
  441.                   instance-flag))
  442.         (cond ((ebut:map
  443.             (function
  444.              (lambda (lbl start end)
  445.                (delete-region start end)
  446.                (ebut:delimit
  447.                 (point)
  448.                 (progn (insert new-label) (point))
  449.                 instance-flag)))
  450.             nil nil lbl-regexp 'include-delims))
  451.               (at-but)
  452.               ((hypb:error "(ebut:operate): No button matching: %s" curr-label))))
  453.         ;; Add a new button.
  454.         (let (start end buf-lbl)
  455.           (cond ((and (marker-position (hypb:mark-marker t))
  456.               (setq start (region-beginning)
  457.                 end (region-end)
  458.                 buf-lbl (buffer-substring start end))
  459.               (equal buf-lbl curr-label))
  460.              nil)
  461.             ((looking-at (regexp-quote curr-label))
  462.              (setq start (point)
  463.                end (match-end 0)))
  464.             (t (setq start (point))
  465.                (insert curr-label)
  466.                (setq end (point))))
  467.           (ebut:delimit start end instance-flag))
  468.         )
  469.       ;; Position point
  470.       (let ((new-key (ebut:label-to-key new-label)))
  471.         (cond ((equal (ebut:label-p) new-key)
  472.            (forward-char 1) (search-backward ebut:start nil t)
  473.            (goto-char (match-end 0)))
  474.           ((let ((regexp (ebut:label-regexp new-key)))
  475.              (or (re-search-forward  regexp nil t)
  476.              (re-search-backward regexp nil t)))
  477.            (goto-char (+ (match-beginning 0) (length ebut:start))))))
  478.       ;; instance-flag might be 't which we don't want to return.
  479.       (if (stringp instance-flag) instance-flag))
  480.       (hypb:error
  481.        "(ebut:operate): Operation failed.  Check button attribute permissions: %s"
  482.        hattr:filename))))
  483.  
  484. (defun    ebut:search (string out-buf &optional match-part)
  485.   "Writes explicit button lines matching STRING to OUT-BUF.
  486. Uses Hyperbole space into which user has written buttons for the search.
  487. By default, only matches for whole button labels are found, optional MATCH-PART
  488. enables partial matches."
  489.   (let*  ((buffers (mapcar (function
  490.                 (lambda (dir)
  491.                   (expand-file-name hattr:filename dir)))
  492.                (hbmap:dir-list)))
  493.       (total 0)
  494.       (firstmatch))
  495.     (save-excursion
  496.       (set-buffer out-buf)
  497.       (setq buffer-read-only nil)
  498.       (widen)
  499.       (erase-buffer)
  500.       (let (currbuf currfile kill-buf src-matches dir)
  501.     (while buffers
  502.       (setq currbuf (car buffers)
  503.         currfile (if (stringp currbuf) currbuf)
  504.         kill-buf (and currfile (not (get-file-buffer currfile)))
  505.         buffers (cdr buffers))
  506.       (if currfile
  507.           (setq currbuf (and (file-readable-p currfile)
  508.                  (find-file-noselect currfile))
  509.             dir (file-name-directory currfile))
  510.         (setq currfile (buffer-file-name currbuf)))
  511.       (and currfile currbuf
  512.            (unwind-protect
  513.            (setq src-matches
  514.              (hbdata:search currbuf string match-part))
  515.          (if kill-buf (kill-buffer currbuf))))
  516.       (if src-matches
  517.           (let (elt matches)
  518.         (while src-matches
  519.           (setq elt (car src-matches))
  520.           (if (null elt) nil
  521.             (setq src-matches (cdr src-matches)
  522.               currfile (expand-file-name (car elt) dir)
  523.               matches (cdr elt)
  524.               currbuf (get-file-buffer currfile)
  525.               kill-buf (not currbuf)
  526.               currbuf (or currbuf
  527.                       (and (file-readable-p currfile)
  528.                        (find-file-noselect currfile))))
  529.             (if (null currbuf)
  530.             (progn (set-buffer out-buf)
  531.                    (insert "ERROR: (ebut:search): \"" currfile
  532.                        "\" is not readable.\n\n"))
  533.               (set-buffer currbuf)
  534.               (unwind-protect
  535.               (save-excursion
  536.                 (widen) (goto-char 1)
  537.                 (let ((case-fold-search t)
  538.                   (regexp
  539.                    (ebut:match-regexp matches match-part)))
  540.                   (setq firstmatch t)
  541.                   (while (re-search-forward regexp nil t)
  542.                 (setq total (1+ total))
  543.                 (let* ((linenum (count-lines (point-min)
  544.                                  (point)))
  545.                        (tag (format "\n%4d:" linenum))
  546.                        lns start end)
  547.                   (setq end (progn (end-of-line) (point))
  548.                     start (progn
  549.                         (goto-char (match-beginning 0))
  550.                         (beginning-of-line) (point))
  551.                     lns (buffer-substring start end))
  552.                   (goto-char end)
  553.                   (save-excursion
  554.                     (set-buffer out-buf)
  555.                     (if firstmatch
  556.                     (progn
  557.                       (insert hbut:source-prefix "\"" 
  558.                           currfile "\"\n")
  559.                       (setq firstmatch nil)))
  560.                     (insert tag lns))))
  561.                   (set-buffer out-buf)
  562.                   (if (not firstmatch) (insert "\n\n"))))
  563.             (if kill-buf (kill-buffer currbuf)))))))))))
  564.     total))
  565.  
  566. ;;; ------------------------------------------------------------------------
  567. (defun    ebut:delimit (start end instance-str)
  568.   "Delimits button label spanning region START to END in current buffer.
  569. If button is already delimited or delimit fails, returns nil, else t.
  570. Inserts INSTANCE-STR after END, before ending delimiter."
  571.   (goto-char start)
  572.   (if (looking-at (regexp-quote ebut:start))
  573.       (forward-char (length ebut:start)))
  574.   (if (ebut:label-p)
  575.       nil
  576.     (if (not (stringp instance-str)) (setq instance-str ""))
  577.     (insert ebut:start)
  578.     (goto-char (setq end (+ end (length ebut:start))))
  579.     (insert instance-str ebut:end)
  580.     (setq end (+ end (length instance-str) (length ebut:end)))
  581.     (and (fboundp 'hproperty:but-add) (hproperty:but-add start end hproperty:but))
  582.     (hbut:comment start end)
  583.     (goto-char end)
  584.     t))
  585.  
  586. (defun    ebut:match-regexp (match-keys match-part)
  587.   "Returns regexp to match to all explicit button keys from MATCH-KEYS."
  588.   (setq match-part (if match-part
  589.                (concat "[^" (substring ebut:end -1) "]*")
  590.              "[ \t\n]*"))
  591.   (concat
  592.    (regexp-quote ebut:start) match-part
  593.    "\\(" (mapconcat (function
  594.              (lambda (key) (ebut:label-regexp key 'no-delim)))
  595.             match-keys "\\|")
  596.    "\\)" match-part (regexp-quote ebut:end)))
  597.  
  598. (defconst ebut:start "<("
  599.   "String matching the start of a hyper-button.")
  600. (defconst ebut:end   ")>"
  601.   "String matching the end of a hyper-button.")
  602. (defconst ebut:instance-sep ":"
  603.   "String of one character, separates an ebut label from its instance num.")
  604.  
  605. ;;; ========================================================================
  606. ;;; gbut class - Global Hyperbole buttons - activated by typing label name
  607. ;;; ========================================================================
  608.  
  609. (defvar gbut:file (expand-file-name hbmap:filename hbmap:dir-user)
  610.   "File that stores Hyperbole buttons accessible by name, global buttons.")
  611.  
  612. (defun gbut:act (label)
  613.   "Activates Hyperbole global button with LABEL."
  614.   (interactive (list (hargs:read-match "Activate global button labeled: "
  615.                        (mapcar 'list (gbut:lbl-list))
  616.                        nil t nil 'ebut)))
  617.   (let* ((lbl-key (hbut:label-to-key label))
  618.      (but (ebut:get lbl-key nil gbut:file)))
  619.     (if but
  620.     (hbut:act but)
  621.       (error "(gbut:act): No global button labeled: %s" label))))
  622.  
  623. (defun gbut:help (label)
  624.   "Displays help for Hyperbole global button with LABEL."
  625.   (interactive (list (hargs:read-match "Report on global button labeled: "
  626.                        (mapcar 'list (gbut:lbl-list))
  627.                        nil t nil 'ebut)))
  628.   (let* ((lbl-key (hbut:label-to-key label))
  629.      (but (ebut:get lbl-key nil gbut:file)))
  630.     (if but
  631.     (hbut:report but)
  632.       (error "(gbut:help): No global button labeled: %s" label))))
  633.  
  634. ;;; ------------------------------------------------------------------------
  635. (defun gbut:key-list ()
  636.   "Returns list of global button label keys."
  637.   (save-excursion
  638.     (if (hbdata:to-entry-buf gbut:file)
  639.     (let ((gbuts))
  640.       (save-restriction
  641.         (narrow-to-region (point) (if (search-forward "\^L" nil t)
  642.                       (point) (point-max)))
  643.         (goto-char (point-min))
  644.         (condition-case ()
  645.         (while (setq gbuts (cons (car (read (current-buffer))) gbuts)))
  646.           (error nil))
  647.         gbuts)))))
  648.  
  649. (defun gbut:lbl-list ()
  650.   "Returns list of global button labels."
  651.   (mapcar 'hbut:key-to-label (gbut:key-list)))
  652.  
  653. ;;; ========================================================================
  654. ;;; hattr class
  655. ;;; ========================================================================
  656.  
  657. (defun    hattr:attributes (obj-symbol)
  658.   "Returns a list of OBJ-SYMBOL's attributes as symbols."
  659.   (if (symbolp obj-symbol)
  660.       (let* ((attr-val-list (symbol-plist obj-symbol))
  661.          (i -1))
  662.     (delq nil (mapcar (function
  663.                (lambda (elt)
  664.                  (setq i (1+ i))
  665.                  (and (= (% i 2) 0) elt)))
  666.               attr-val-list)))))
  667.  
  668. (defun    hattr:clear (hbut)
  669.   "Removes all of HBUT's attributes except `variable-documentation'."
  670.   (let (sublist)
  671.     (or (symbolp hbut)
  672.     (error "(hattr:clear): Argument not a Hyperbole button: %s" hbut))
  673.     (if (setq sublist (memq 'variable-documentation (symbol-plist hbut)))
  674.     (progn
  675.       (setcdr (cdr sublist) nil)
  676.       (setplist hbut sublist))
  677.       (setplist hbut nil)
  678.       )))
  679.  
  680. (defun    hattr:copy (from-hbut to-hbut)
  681.   "Copies attributes FROM-HBUT TO-HBUT, eliminating attributes TO-HBUT had.
  682. Returns TO-HBUT."
  683.   (mapcar
  684.    (function
  685.     (lambda (hbut)
  686.       (or (and hbut (symbolp hbut))
  687.       (error "(hattr:clear): Argument not a Hyperbole button: %s" hbut))))
  688.    (list from-hbut to-hbut))
  689.   (unwind-protect
  690.       nil
  691.     (hattr:clear to-hbut)
  692.     (setplist to-hbut (copy-sequence (symbol-plist from-hbut))))
  693.   to-hbut)
  694.  
  695. (defun    hattr:get (obj-symbol attr-symbol)
  696.   "Returns value of OBJ-SYMBOL's attribute ATTR-SYMBOL."
  697.   (get obj-symbol attr-symbol))
  698.  
  699. (defun    hattr:list (obj-symbol)
  700.   "Returns a property list of OBJ-SYMBOL's attributes.
  701. Each pair of elements is: <attrib-name> <attrib-value>."
  702.   (if (symbolp obj-symbol)
  703.       (symbol-plist obj-symbol)
  704.     (error "(hattr:list): Argument not a symbol: %s" obj-symbol)))
  705.  
  706. (defun    hattr:memq (attr-symbol obj-symbol)
  707.   "Returns t if ATTR-SYMBOL is in OBJ-SYMBOL's attribute list, else nil."
  708.   (and (symbolp obj-symbol) (symbolp attr-symbol)
  709.        (let* ((attr-val-list (symbol-plist obj-symbol))
  710.           (attr-list (let ((i -1))
  711.                (delq nil (mapcar
  712.                       (function
  713.                        (lambda (elt)
  714.                      (setq i (1+ i))
  715.                      (and (= (% i 2) 0) elt)))
  716.                       attr-val-list)))))
  717.      (if (memq attr-symbol attr-list) t))))
  718.  
  719. (defun    hattr:report (attrib-list)
  720.   "Pretty prints to standard-output attribute-value pairs from ATTRIB-LIST.
  721. Ignores nil valued attributes.  Returns t unless no attributes are printed."
  722.   (let ((has-attr) attr val len)
  723.     (if (or (null attrib-list) (not (listp attrib-list))
  724.         ;; odd number of elements?
  725.         (= (% (length attrib-list) 2) 1))
  726.     nil
  727.       (while (setq attr (car attrib-list))
  728.     (setq val (car (setq attrib-list (cdr attrib-list)))
  729.           attrib-list (cdr attrib-list))
  730.     (if val
  731.         (progn
  732.           (setq has-attr t
  733.             attr (symbol-name attr)
  734.             len (max (- 16 (length attr)) 1))
  735.           (princ "   ") (princ attr) (princ ":")
  736.           (princ (make-string len ? ))
  737.           (let (str)
  738.         (prin1 (cond ((string-match "time" attr)
  739.                   (htz:date-unix val
  740.                          (and (>= (aref val 0) ?0)
  741.                           (<= (aref val 0) ?9)
  742.                           "GMT") htz:local))
  743.                  ((and (setq str (if (stringp val) val
  744.                            (prin1-to-string val)))
  745.                    (string-match "\\`actypes::" str))
  746.                   (intern (substring str (match-end 0))))
  747.                  (t val))))
  748.           (terpri))))
  749.       has-attr)))
  750.  
  751. (defun    hattr:save ()
  752.   "Saves button attribute file for current directory, if modified.
  753. Suitable for use as part of 'write-file-hooks'."
  754.   (let* ((bd-file (expand-file-name hattr:filename default-directory))
  755.      (buf (and (stringp default-directory)
  756.            (get-file-buffer bd-file))))
  757.     (if (and ebut:hattr-save buf (not (eq buf (current-buffer))))
  758.     (let ((ebut:hattr-save));; Prevents 'write-file-hooks' looping.
  759.       (and (buffer-modified-p buf) 
  760.            (save-excursion
  761.          (set-buffer buf) (save-buffer)
  762.          ;; Unlock button attribute file; kill buffer so user is
  763.          ;; never holding a buffer which is out of sync with file,
  764.          ;; due to some other user's edits.
  765.          ;; Maybe this should be user or site configurable.
  766.          (or (buffer-modified-p buf) (kill-buffer buf))
  767.          )))))
  768.   ;; Must return nil, so can be used as part of write-file-hooks.
  769.   nil)
  770.  
  771. (defun    hattr:set (obj-symbol attr-symbol attr-value)
  772.   "Sets OBJ-SYMBOL's attribute ATTR-SYMBOL to ATTR-VALUE."
  773.   (put obj-symbol attr-symbol attr-value))
  774.  
  775. (fset    'hattr:summarize 'hattr:report)
  776.  
  777. (defvar   hattr:filename ".hypb"
  778.   "Per directory file name in which explicit button attributes are stored.
  779. If you change its value, you will be unable to use buttons created by
  780. others who use a different value!")
  781.  
  782. ;;; ========================================================================
  783. ;;; hbut class - abstract
  784. ;;; ========================================================================
  785.  
  786. (defun    hbut:act (hbut)
  787.   "Performs action for explicit or implicit Hyperbole button symbol HBUT."
  788.   (and hbut (apply 'actype:act (hattr:get hbut 'actype)
  789.            (hattr:get hbut 'args))))
  790.  
  791. (defun    hbut:action (hbut)
  792.   "Returns appropriate action for Hyperbole button symbol HBUT."
  793.   (let ((categ (hattr:get hbut 'categ)) (atype) (action))
  794.     (if (eq categ 'explicit)
  795.     (progn (setq action (hattr:get hbut 'action)
  796.              atype  (hattr:get hbut 'actype))
  797.            (if (= (length (symbol-name atype)) 2)
  798.            atype
  799.          (or action (actype:action atype))))
  800.       ;; Must be an implicit button.
  801.       (if (fboundp atype) atype))))
  802.  
  803. (defun    hbut:at-p ()
  804.   "Returns symbol for explicit or implicit Hyperbole button at point or nil."
  805.   (or (ebut:at-p) (ibut:at-p)))
  806.  
  807.  
  808. (defun    hbut:comment (start end)
  809.   "Comment button label spanning region START to END in current buffer.
  810. Use buffer commenting grammar, if any, otherwise don't comment."
  811.   (save-excursion
  812.     (if comment-start
  813.     (if (or (equal comment-end "")
  814.         (null comment-end))
  815.         (progn
  816.           (beginning-of-line)
  817.           (if (search-forward comment-start start t)
  818.           nil
  819.         (goto-char start)
  820.         (insert comment-start)
  821.         (if (/= (preceding-char) ? )
  822.             (insert ? ))))
  823.       ;; Comments have both start and end delimiters
  824.         (if (and (re-search-backward
  825.             (concat (regexp-quote comment-start) "\\|"
  826.                 (regexp-quote comment-end))
  827.             nil t)
  828.            (looking-at (regexp-quote comment-start)))
  829.           nil
  830.         (goto-char start)
  831.         (insert comment-start)
  832.         (if (/= (preceding-char) ? )
  833.         (insert ? ))
  834.         (goto-char (+ (point) (- end start)))
  835.         (if (/= (following-char) ? )
  836.         (insert ? ))
  837.         (insert comment-end)
  838.         )))))
  839.  
  840. ;;; Regexps derived in part from "filladapt.el" under the GPL, Copyright
  841. ;;; 1989 Kyle E. Jones.
  842. (defvar   hbut:fill-prefix-regexps
  843.   '(
  844.     ;; Included text in news or mail messages
  845.     "\n[ \t]*\\([:|<>]+ *\\)+"
  846.     ;; Included text generated by SUPERCITE.  We can't hope to match all
  847.     ;; the possible variations.
  848.     "\n[ \t]*[^'`\"< \t]*> *"
  849.     ;; Lisp comments
  850.     "\n[ \t]*\\(;+[ \t]*\\)+"
  851.     ;; UNIX shell comments
  852.     "\n[ \t]*\\(#+[ \t]*\\)+"
  853.     ;; C++ comments
  854.     "\n[ \t]*//[/ \t]+"
  855.     ;; C or Pascal comments, one open and close per line, so match close
  856.     ;; then open.
  857.     "\\*+[/\)][ \t]*\n+[ \t]*[/\(]\\*+"
  858.     "}[ \t]*\n+[ \t]*{"
  859.     ;; Eiffel or Sather comments
  860.     "\n[ \t]*--[ \t]+"
  861.     ;; Fortran comments
  862.     "\n[Cc][ \t]+"
  863.     ;; Postscript comments
  864.     "\n[ \t]*\\(%+[ \t]*\\)+"
  865.     )
  866.   "List of regexps of fill prefixes to remove from the middle of buttons.")
  867.  
  868. (defun    hbut:fill-prefix-remove (label)
  869.   "Removes any recognized fill prefix from within LABEL.
  870. 'hbut:fill-prefix-regexps' is a list of fill prefixes to recognize."
  871.   (if (string-match "\n" label)
  872.       (mapcar
  873.        (function
  874.     (lambda (fill-prefix)
  875.       (and (string-match "\n" label)
  876.            (setq label
  877.              (hypb:replace-match-string fill-prefix label " " t)))))
  878.        hbut:fill-prefix-regexps))
  879.   label)
  880.  
  881. (defun    hbut:is-p (object)
  882.   "Returns non-nil if object denotes a Hyperbole button."
  883.   (and (symbolp object) (hattr:get object 'categ)))
  884.  
  885. (fset    'hbut:key-src      'ebut:key-src)
  886. (fset    'hbut:key-to-label 'ebut:key-to-label)
  887.  
  888. (defun    hbut:label (hbut)
  889.   "Returns the label for Hyperbole button symbol HBUT."
  890.   (if (hbut:is-p hbut)
  891.       (hbut:key-to-label (hattr:get hbut 'lbl-key))
  892.     (error "(hbut:label): Argument is not a Hyperbole button symbol, '%s'"
  893.        hbut)))
  894.  
  895. (fset    'hbut:label-p      'ebut:label-p)
  896. (fset    'hbut:label-to-key 'ebut:label-to-key)
  897.  
  898. (defun    hbut:report (&optional arg)
  899.   "Pretty prints the attributes of a button or buttons.
  900.  
  901. Takes an optional ARG interpreted as follows:
  902.   a button symbol - report on that button;
  903.   nil             - report on button at point, if any;
  904.   integer > 0     - report on all explicit buttons in buffer, alphabetize;
  905.   integer < 1     - report on all explicit buttons in occurrence order;
  906.  
  907. Returns number of buttons reported on or nil if none."
  908.   (setq arg (cond ((or (integerp arg) (symbolp arg)) arg)
  909.           ((listp arg)
  910.            (if (integerp (setq arg (car arg))) arg 1))
  911.           (t 1)))
  912.   (let* ((but (if (and arg (symbolp arg)) arg (hbut:at-p)))
  913.      (curr-key (and but (hattr:get but 'lbl-key)))
  914.      (key-src (or (and but (hattr:get but 'loc)) (hbut:key-src)))
  915.      (lbl-lst (cond ((not arg)
  916.              (if curr-key (list (ebut:key-to-label curr-key))))
  917.             ((symbolp arg) (if curr-key
  918.                        (list (hbut:key-to-label
  919.                           (hattr:get arg 'lbl-key)))))
  920.             ((< arg 1) (ebut:list))
  921.             (t (sort (ebut:list)
  922.                  (function
  923.                   (lambda (s1 s2)
  924.                     (string< (downcase s1) (downcase s2))))))))
  925.      (key-buf (current-buffer))
  926.      (buf-name (hypb:help-buf-name))
  927.      (attribs))
  928.     (if lbl-lst
  929.     (progn
  930.       (with-output-to-temp-buffer buf-name
  931.         (princ hbut:source-prefix)
  932.         (prin1 key-src)
  933.         (terpri)
  934.         (terpri)
  935.         (mapcar
  936.          (function
  937.           (lambda (lbl)
  938.         (if (setq but
  939.               (cond ((or (null arg) (symbolp arg)) but)
  940.                 (t (ebut:get (ebut:label-to-key lbl) key-buf)))
  941.               attribs (hattr:list but))
  942.             (progn
  943.               (princ (if (ibut:is-p but)
  944.                  lbl
  945.                    (concat ebut:start lbl ebut:end)))
  946.               (terpri)
  947.               (let ((doc (actype:doc but (= 1 (length lbl-lst)))))
  948.             (if doc
  949.                 (progn
  950.                   (princ "  ")
  951.                   (princ doc)
  952.                   (terpri))))
  953.               (hattr:report
  954. ;;               (if (eq (car (cdr (memq 'categ attribs))) 'explicit)
  955. ;;               (memq 'action attribs)
  956. ;;             (memq 'categ attribs))
  957.                attribs)
  958.               (terpri))
  959.           )))
  960.          lbl-lst))
  961.       (length lbl-lst)))))
  962.  
  963. (defun    hbut:source (&optional full)
  964.   "Returns Hyperbole source buffer or file given at point.
  965. If a file, always returns a full path if optional FULL is non-nil."
  966.   (goto-char (match-end 0))
  967.   (cond ((looking-at "#<buffer \\([^ \n]+\\)>")
  968.      (get-buffer (buffer-substring (match-beginning 1)
  969.                        (match-end 1))))
  970.     ((looking-at "\".+\"")
  971.      (let* ((file (buffer-substring (1+ (match-beginning 0))
  972.                     (1- (match-end 0))))
  973.         (absolute (file-name-absolute-p file)))
  974.        (if (and full (not absolute))
  975.            (expand-file-name file default-directory)
  976.          file)))))
  977.  
  978. (fset    'hbut:summarize 'hbut:report)
  979.  
  980. (defvar   hbut:current nil
  981.   "Currently selected Hyperbole button.
  982. Available to action routines.")
  983.  
  984. (defconst hbut:source-prefix moccur-source-prefix
  985.   "String found at start of a buffer containing only a hyper-button menu.
  986.    This expression should be followed immediately by a file-name indicating the
  987. source file for the buttons in the menu, if any.")
  988.  
  989. ;;; ========================================================================
  990. ;;; htype class - Hyperbole Types, e.g. action and implicit button types
  991. ;;; ========================================================================
  992.  
  993. (require 'set)
  994.  
  995. (defun    htype:body (htype-sym)
  996.   "Return body for HTYPE-SYM.  If HTYPE-SYM is nil, return nil."
  997.   (and htype-sym (hypb:indirect-function htype-sym)))
  998.  
  999. (defun    htype:category (type-category)
  1000.   "Return list of symbols in Hyperbole TYPE-CATEGORY in priority order.
  1001. Symbols contain category component.
  1002. TYPE-CATEGORY should be 'actypes, 'ibtypes or nil for all."
  1003.   (let ((types (symset:get type-category 'symbols))
  1004.     (categ-name (symbol-name type-category)))
  1005.     (mapcar (function
  1006.          (lambda (type)
  1007.            (intern (concat categ-name "::" (symbol-name type)))))
  1008.         types)))
  1009.  
  1010. ;; Thanks to JWZ for help on this.
  1011. (defmacro htype:create (type type-category doc params body property-list)
  1012.   "Create a new Hyperbole TYPE within TYPE-CATEGORY (both unquoted symbols).
  1013. Third arg DOC is a string describing the type.
  1014. Fourth arg PARAMS is a list of parameters to send to the fifth arg BODY,
  1015. which is a list of forms executed when the type is evaluated.
  1016. Sixth arg PROPERTY-LIST is attached to the new type's symbol.
  1017.  
  1018. This symbol is returned."
  1019.   (let* ((sym (htype:symbol type type-category))
  1020.     (action (nconc (list 'defun sym params doc) body)))
  1021.     (` (progn
  1022.      (, action)
  1023.      (setplist '(, sym) (, property-list))
  1024.      (symset:add '(, type) '(, type-category) 'symbols)
  1025.      (run-hooks 'htype:create-hook)
  1026.      '(, sym)))))
  1027.  
  1028. (defun    htype:delete (type type-category)
  1029.   "Delete a Hyperbole TYPE derived from TYPE-CATEGORY (both symbols).
  1030. Return the Hyperbole symbol for the TYPE if it existed, else nil."
  1031.   (let* ((sym (htype:symbol type type-category))
  1032.      (exists (fboundp 'sym)))
  1033.     (setplist sym nil)
  1034.     (symset:delete type type-category 'symbols)
  1035.     (fmakunbound sym)
  1036.     (run-hooks 'htype:delete-hook)
  1037.     (and exists sym)))
  1038.  
  1039. (defun    htype:doc (type)
  1040.   "Return documentation for Hyperbole TYPE, a symbol."
  1041.   (documentation type))
  1042.  
  1043. (defun    htype:names (type-category &optional sym)
  1044.   "Return list of current names for Hyperbole TYPE-CATEGORY in priority order.
  1045. Names do not contain category component.
  1046. TYPE-CATEGORY should be 'actypes, 'ibtypes or nil for all.
  1047. When optional SYM is given, return the name for that symbol only, if any."
  1048.   (let ((types (symset:get type-category 'symbols))
  1049.     (sym-name (and sym (symbol-name sym))))
  1050.     (if sym-name
  1051.     ;; Strip category from sym-name before looking for a match.
  1052.     (progn (if (string-match "::" sym-name)
  1053.            (setq sym (intern (substring sym-name (match-end 0)))))
  1054.            (if (memq sym types) (symbol-name sym)))
  1055.       (mapcar 'symbol-name types))))
  1056.  
  1057. ;;; ------------------------------------------------------------------------
  1058.  
  1059. (defun   htype:symbol (type type-category)
  1060.   "Return Hyperbole type symbol composed from TYPE and TYPE-CATEGORY (both symbols)."
  1061.   (intern (concat (symbol-name type-category) "::"
  1062.           (symbol-name type))))
  1063.  
  1064. ;;; ========================================================================
  1065. ;;; ibut class - Implicit Hyperbole Buttons
  1066. ;;; ========================================================================
  1067.  
  1068. (defun    ibut:at-p (&optional key-only)
  1069.   "Returns symbol for implicit button at point, else nil.
  1070. With optional KEY-ONLY, returns only the label key for button."
  1071.   (let ((types (htype:category 'ibtypes))
  1072.     ;; Global var used in (hact) function, don't delete.
  1073.     (hrule:action 'actype:identity)
  1074.     (itype)
  1075.     (args)
  1076.     (is-type))
  1077.     (or key-only (hattr:clear 'hbut:current))
  1078.     (while (and (not is-type) types)
  1079.       (setq itype (car types))
  1080.       (if (setq args (funcall itype))
  1081.       (setq is-type itype)
  1082.     (setq types (cdr types))))
  1083.     (if is-type
  1084.     (if key-only
  1085.         (hattr:get 'hbut:current 'lbl-key)
  1086.       (hattr:set 'hbut:current 'loc (save-excursion
  1087.                       (hbut:key-src 'full)))
  1088.       (hattr:set 'hbut:current 'categ is-type)
  1089.       (or (hattr:get 'hbut:current 'args)
  1090.           (not (listp args))
  1091.           (progn
  1092.         (hattr:set 'hbut:current 'actype
  1093.                (or
  1094.                  ;; Hyperbole action type
  1095.                  (intern-soft (concat "actypes::"
  1096.                           (symbol-name (car args))))
  1097.                  ;; Regular Emacs Lisp function symbol
  1098.                  (car args)
  1099.                  ))
  1100.         (hattr:set 'hbut:current 'args (cdr args))))
  1101.       'hbut:current))))
  1102.  
  1103. (defun    ibut:is-p (object)
  1104.   "Returns non-nil if object denotes an implicit Hyperbole button."
  1105.   (if (symbolp object)
  1106.       (let ((categ (hattr:get object 'categ)))
  1107.     (and categ (string-match "^ibtypes::" (symbol-name categ))))))
  1108.  
  1109. (defun    ibut:label-p ()
  1110.   "Returns key for Hyperbole implicit button label that point is on or nil."
  1111.   (ibut:at-p 'key-only))
  1112.  
  1113. (defun    ibut:label-set (label &optional start end)
  1114.   "Sets current implicit button attributes from LABEL and START, END position.
  1115. START and END are OPTIONAL.
  1116. If LABEL is a list, it is assumed to contain all arguments."
  1117.   (cond ((stringp label)
  1118.      (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key label))
  1119.      (and start (hattr:set    'hbut:current 'lbl-start start))
  1120.      (and end   (hattr:set    'hbut:current 'lbl-end   end)))
  1121.     ((and label (listp label))
  1122.      (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key (car label)))
  1123.      (hattr:set    'hbut:current 'lbl-start    (nth 1 label))
  1124.      (hattr:set    'hbut:current 'lbl-end      (nth 2 label)))
  1125.     (t (error "(ibut:label-set): Invalid label arg: '%s'" label)))
  1126.   t)
  1127.  
  1128. ;;; ========================================================================
  1129. ;;; ibtype class - Implicit button types
  1130. ;;; ========================================================================
  1131.  
  1132. (fset    'defib 'ibtype:create)
  1133. (put     'ibtype:create 'lisp-indent-function 'defun)
  1134. (defmacro ibtype:create (type params doc at-p &optional to-p style)
  1135.   "Creates implicit button TYPE (unquoted sym) with PARAMS, described by DOC.
  1136. PARAMS are presently ignored.
  1137.  
  1138.   AT-P is a boolean form of no arguments which determines whether or not point
  1139. is within a button of this type.
  1140.   Optional TO-P is a boolean form which moves point immediately after the next
  1141. button of this type within the current buffer and returns a list of (button-
  1142. label start-pos end-pos), or nil when none is found.
  1143.   Optional STYLE is a display style specification to use when highlighting
  1144. buttons of this type; most useful when TO-P is also given.
  1145.  
  1146. Returns symbol created when successful, else nil.  Nil indicates that action
  1147. type for ibtype is presently undefined."
  1148.   (if type
  1149.       (let ((to-func (if to-p (action:create nil (list to-p))))
  1150.         (at-func (list at-p)))
  1151.     (` (htype:create (, type) ibtypes (, doc) nil (, at-func)
  1152.              (list 'to-p (, to-func) 'style (, style)))))))
  1153.  
  1154. (defun    ibtype:delete (type)
  1155.   "Deletes an implicit button TYPE (a symbol).
  1156. Returns TYPE's symbol if it existed, else nil."
  1157.   (htype:delete type 'ibtypes))
  1158.  
  1159. ;;; ========================================================================
  1160. ;;; symset class - Hyperbole internal symbol set maintenance
  1161. ;;; ========================================================================
  1162.  
  1163. (require 'set)
  1164.  
  1165. (defun    symset:add (elt symbol prop)
  1166.   "Adds ELT to SYMBOL's PROP set.
  1167. Returns nil iff ELT is already in SET.  Uses 'eq' for comparison."
  1168.   (let* ((set (get symbol prop))
  1169.      (set:equal-op 'eq)
  1170.      (new-set (set:add elt set)))
  1171.     (and new-set (put symbol prop new-set))))
  1172.  
  1173. (fset    'symset:delete 'symset:remove)
  1174.  
  1175. (defun    symset:get (symbol prop)
  1176.   "Returns SYMBOL's PROP set."
  1177.   (get symbol prop))
  1178.  
  1179. (defun    symset:remove (elt symbol prop)
  1180.   "Removes ELT from SYMBOL's PROP set and returns the new set.
  1181. Assumes PROP is a valid set.  Uses 'eq' for comparison."
  1182.   (let ((set (get symbol prop))
  1183.     (set:equal-op 'eq))
  1184.     (put symbol prop (set:remove elt set))))
  1185.  
  1186.  
  1187. (provide 'hbut)
  1188.